COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 -*-LISP-*-
C00019 ENDMK
C⊗;
;;; -*-LISP-*-

(COMMENT CORE 80. BPS 36000.)

;This will compose a MACLISP compiler, along with the faslap assembler,
;    using COMLAP;COMPLR FASL		(COMPLR.FAS on DEC systems)
;		  FASLAP FASL		(FASLAP.FAS on DEC systems)
;	   [	 663CF FASL]		;assuming COMPLR version 663
;	   [	 263FF FASL]		;assuming FASLAP version 223
;	   COMMON;GETMID FASL		(GETMID.FAS on DEC systems)

;It will ask a question regarding "PURE" and the answer means
;	<SPACE> or "1", 	use 1 UUOLINK page [in new scheme, merely
;				    equivalent to (SSTATUS UUOLI)]
;	T			pure load, but no UUOLINKS
;	NIL 			regular FASLOAD
;	LAP 			use COMPLR LAP, and ask again whether
;					FASLAP is wanted
;	XC			(SSTATUS FEATURE XC), use 1 UUOLINK 
;					page - experimental compiler
;Ordinarily the result will be :PDUMPI'd (by SUSPEND) as 
;   COMLAP;CL.DMP <complrverno>  [there is a link on SYS for TS COMPLR
;				to COMLAP;CL.DMP >]
;However, if the other machine dumps notice that there is no UUOLINKS 
;page, or that the compiler is experimental, they will go out on JONL 
;directory the same as on MC.  Thus there is a link for XQCOMPLR to
;JONL;XQ.DMP >


((LAMBDA (PUTPROP) 
	 (SETQ *RSET NIL NOUUO NIL)
	 (EVAL (READ))								;Gets moby PROG below
	 (AND (BOUNDP 'UREAD) (FILEP UREAD) (CLOSE UREAD))
	 (COND ((STATUS FEATURE ITS) 
		(INPUSH -1) 							;Closes this INIT file
		(AND (STATUS SSTATUS FLUSH) (SSTATUS FLUSH T))
		(CDUMP 0 (MAKNAM (NCONC (EXPLODEN (COND ((OR (NOT (FIXP PURE))
							     (STATUS FEATURE XC))
							 '|DSK:JONL;XC.DMP |)
							(T '|COMLAP;CL.DMP |)))
					(EXPLODEN COMPLRVERNO)))))
	       (T (INPUSH -1) (CDUMP '|SAVE SYS NEWCOM|))) 					;Closes this INIT file
	 (SETQ PURE NIL))
   PUTPROP)

  (PROG (GL NORET TIME PVR ARITHP LINE EFFS CCLOAD-CNT OPVRL LVRL FLPDL 
	 PRSSL ALARMCLOCK SLOTX REGACS NUMACS MODELIST BVARS FASLOAD 
	 UNSFLST FXPDL REGPDL NLNVTHTBP *PURE CRUNIT)
	(SETQ RUNTIME (RUNTIME) TIME (TIME) FXPDL (STATUS FEATURE NOLDMSG)
	      CRUNIT (CRUNIT) NORET T *PURE T)
	(ALLOC '(FIXNUM (2048. 10240. .25) FLONUM (256. 4096. .10) 
		 BIGNUM (256. 4096. .10) SYMBOL (1536. 8192. .25) 
		 ARRAY (64. 1024. 64.)))
	(AND (STATUS FEATURE ITS) (ALLOC '(LIST (14336. 40960. .35))))
	(SSTATUS FEATURE NOLDMSG)
	(SETQ EFFS 3.0 FLPDL T)
	(SETQ NUMACS '(LAMBDA NIL 			;TURNS ALARM OFF
			(ALARMCLOCK 'TIME -1)
			((LAMBDA (↑W ↑R) (PRINC '|/
Clock-OFF |)) NIL NIL)
			(SETQ ALARMCLOCK NIL ↑W T BVARS T 
			      SLOTX REGACS))
	      REGACS '(LAMBDA NIL 			;TURNS ALARM ON
			(SETQ ALARMCLOCK MODELIST ↑W NIL BVARS NIL 
			      SLOTX NUMACS ARITHP 40.0 LINE 10.) 
			((LAMBDA (↑W ↑R) (PRINC '|/
Clock-ON |)) NIL NIL)
			(ALARMCLOCK 'TIME 1.))) 
	(COMMENT 
		;SLOTX holds either NUMACS or REGACS, functions which hac the ALARMCLOCK
		;	(NUMACS) turns ALARMCLOCK feature on
		;	(REGACS) turns it off
		;LINE is the interval between alarm rings, 
		;EFFS is the epsilonics - two tics within a realtime of less 
		;    than EFFS cause the second to be ignored
		;PVR is the time at which the previous alarm rang
		;ARITHP is the time at which the interval should be slowed,
		;    [i.e., doubled] we want alarms less often as time goes by 
		;RUNTIME is the RUNTIME before beginning
		;TIME is the realTIME before beginning
		;CCLOAD-CNT is a temporary time holder
		;BVARS causes a veto on message printers
	 )
	(SETQ MODELIST 
	      '(LAMBDA (VGO) 
		  (COND (BVARS (ALARMCLOCK 'TIME -1))
			(T (COND ((AND (> (-$ (SETQ CCLOAD-CNT (TIME)) OPVRL) EFFS)
				       (NOT BVARS))
				  (PRINC '|/
Using |) 
				  (PRINC (*QUO (FIX (*QUO (- (RUNTIME) RUNTIME) 1.0E5)) 10.0))
				  (PRINC '| secs so far, out of |)
				  (PRINC (*QUO (FIX (*$ (-$ (TIME) TIME) 10.0)) 10.0))
				  (PRINC '/ )
				  (SETQ CCLOAD-CNT (TIME))))
			    (COND ((> (-$ (SETQ OPVRL CCLOAD-CNT) TIME) ARITHP) 
				   (SETQ ARITHP (*$ 2.0 ARITHP) LINE (* 2 LINE))))
			    (ALARMCLOCK 'TIME LINE)))))
	(SETQ ↑Q NIL)
     A  (PRINC '|/
PURE=|)
	(COND ((NOT (STATUS FEATURE ITS)) 
	       (AND (FIXP (SETQ PURE (READ)))
		    (PLUSP PURE)
		    (OR (STATUS FEATURES SAIL)
			(SETQ PURE (MINUS PURE)))))
	      ((= (TYIPEEK) 32.)
	       (CURSORPOS 'B)
	       (PRINC '|1 |)
	       (SETQ PURE 1))
	      ((= (TYIPEEK) 63.)			;?
	       (TYI)
	       (PRINC '|/
;	<SPACE> or "1", 	use 1 UUOLINK page [in new scheme, merely/
;				    equivalent to (SSTATUS UUOLI)]/
;	T			pure load, but no UUOLINKS/
;	NIL 			regular FASLOAD/
;	LAP 			use COMPLR LAP, and ask again whether/
;					FASLAP is wanted/
;	XC			(SSTATUS FEATURE XC), use 1 UUOLINK /
;					page - experimental compiler/
|)
	       (GO A))
	      ((MEMQ (SETQ PURE (READ)) '(XC LAP)) 
		(SSTATUS FEATURE XC)
		(AND (EQ PURE 'XC) (SETQ PURE 1))))
	(SETQ OPVRL (TIME))
	(COND ((STATUS FEATURE ITS)
		(SSTATUS TTYIN 30. '(LAMBDA (VGO VGOL) (FUNCALL SLOTX)))
		(FUNCALL REGACS)))						;SETS UP SLOTX, AND STARTS ALARMCLOCK
	(AND (NOT BVARS)
	     (PRINC '|(In LISP version |)
	     (PRINC (STATUS LISPV))
	     (PRINC '|)|))
	(OR (NOT (STATUS FEATURE ITS))
	    (NOT (STATUS HACTR))
	    (VALRET (COND ((OR (NOT (FIXP PURE)) (STATUS FEATURE XC))
			   '|↔≠/:JCL/
XCOMPL≠≠J:VP |)
			  ('|↔≠/:JCL/
COMPLR≠≠J:VP |))))
	(SETQ LVRL '((LAMBDA (PURE) 						;LOADS LAP IF NECESSARY
			     (COND ((GET 'LAP 'FSUBR)) 
				   ((PROBEF (SETQ LVRL (GET 'LAP 'AUTOLOAD)))
				    (LOAD LVRL))
				   ((PROBEF (SETQ LVRL (LIST (CONS 'DSK (CDR CRUNIT))
							     (CAR LVRL)
							     (CADR LVRL))))
				    (LOAD LVRL)))
			     (COND ((GET 'GETMIDASOP 'FSUBR)) 
				   ((PROBEF (SETQ LVRL (GET 'GETMID 'AUTOLOAD)))
				    (LOAD LVRL))
				   ((PROBEF (SETQ LVRL (LIST (CONS 'DSK (CDR CRUNIT))
							     (CAR LVRL)
							     (CADR LVRL))))
				    (LOAD LVRL)))
			     (PAGEBPORG)
			     (PURIFY 0 0 'BPORG)
			     (SETQ LVRL T))
			  T)
	      GL '((LAMBDA (PURE)
			   (SETQ LET () )
			   (COND ((GET 'LET 'MACRO))
				 ((SETQ GL (GET 'LET 'AUTOLOAD)) (LOAD GL))
				 ((STATUS FEATURE ITS) (FASLOAD LET FASL DSK LIBLSP))))
		      T))
	(AND PURE (PAGEBPORG)) 
	(SETQ DEV (LIST 'DSK (COND ((STATUS FEATURE ITS) 'COMLAP)
				   ((STATUS UDIR)))))
      C (SETQ REGPDL (CONS DEV '(COMPLR FASL)))
	(AND (NOT (STATUS FEATURE ITS))
	     (NOT (PROBEF REGPDL))
	     (PROG2 (PRINC '|/
Please set up "DEV" to a list of the device and directory /
names to use for the loading the COMPLR and FASLAP FASL files/
|)
		    (BREAK ULUZ)
		    (GO C)))
	(SETQ PRSSL (CONS DEV '(FASLAP FASL)))
	(AND (NULL (PROBEF PRSSL)) (SETQ PRSSL NIL))
	(COND ((AND (NOT (EQ PURE 'LAP)) (PROBEF REGPDL))
		(GETSP 35000.)
		(AND (NULL PRSSL) (EVAL LVRL))
		(EVAL GL)
		(AND (NOT BVARS) 
		     (PRINC '|/
Fazloading COMPLR FASL|) )
		(LOAD REGPDL)
		(AND (NOT BVARS) 
		     (PRINC '|/
  (Compiler version number |)
		     (PRINC COMPLRVERNO)
		     (PRINC '|) |))
		(COND ((STATUS FEATURES SAIL)
		       (PRINC '|/
Fazloading utilities/
|)
		      (princ '|Getmidasop, |)
		      (FASLOAD GETMID fas dsk (mac lsp))
		      (APPLY 'CRUNIT (LIST 'DSK (STATUS UDIR)))
		      (princ '|eread, |)
		      (FASLOAD EREAD fas dsk (mac lsp))
		      (princ '|direct, |)
		      (FASLOAD DIRECT fas dsk (new lsp))
		      (princ '|require, |)
		      (FASLOAD NCOREQ fas dsk (new lsp))
		      (princ '|string, |)
		      (FASLOAD STRING fas dsk (mac lsp))
		      (princ '|match, |)
		      (FASLOAD MATCH fas)
		      (*FEXPR EREAD)
		      (*FEXPR CODE)
		      (*FEXPR MAIL)
		      (SPECIAL ↑Q ↑R ↑W ↑V)
		      (princ '|and loaded./
|)
   		      (FASLOAD LOADED fas)
		      (PRINC '|/
Loading done!|)))
		(PAGEBPORG))
	      ((STATUS FEATURE ITS)
		 (COND ((EQ PURE 'LAP) 
			(SSTATUS TTY (BOOLE 7 (CAR (SETQ UNSFLST (STATUS TTY))) 2←24.) (CADR UNSFLST))
			(PRINC '|/
Purified LAP code?(Y, N, or number) |)
			(AND (= (TYIPEEK) 32.) (READCH))
			(SETQ PURE (COND ((LESSP 47. (TYIPEEK) 58.) (READ))
					 ((EQ (READCH) 'Y))))
			(PRINC '|/
FASLAP too?(Y or N) |)
			(SETQ FLPDL (EQ (READCH) 'Y))
			(SSTATUS TTY (CAR UNSFLST) (CADR UNSFLST))))
		 (EVAL LVRL)
		 (EVAL GL)
		 (AND (NOT BVARS) (PRINC '|/
LAPping in COMPLR LAP |))
		 (LOAD (CONS DEV '(COMPLR LAP))) )
	      (T (PRINC '|You Lose, Bunkie! Get your files straightened out!|)
		 (BREAK ULUZ)
		 (GO C)))
	(COND ((PROBEF (SETQ GL (LIST DEV 
				      (MAKNAM (NCONC (EXPLODEN COMPLRVERNO)
						     '(C F)))
				      'FASL))) 
	       (AND (NOT BVARS) 
		    (PRINC '|/
Fazloading COMPLR fix file |)
		    (PRINC (CADR GL)))
	       (LOAD GL)))
	((LAMBDA (PURE *PURE) (GETMIDASOP NIL)) T T)				;MAKE SURE GETMIDASOP IS IN
	(COND ((NULL FLPDL))
	      (PRSSL								;NIL IF FASLAP FASL MISSING
		(AND (NOT BVARS) 
		     (PRINC '|/
Fazloading FASLAP FASL|))
		(LOAD PRSSL)
		(AND (NOT BVARS) 
		     (PRINC '|/
  (FASLAP version number |)
		     (PRINC FASLVERNO)
		     (PRINC '|) |)))
	      ((PROBEF (SETQ PRSSL (CONS DEV '(FASLAP LAP))))
	       (AND (NOT BVARS) (PRINC '|/
LAPping up FASLAP file |))
	       (LOAD (CONS DEV '(FASLAP LAP))))
	      (T (PRINC '|FASLAP file is missing! |)
		 (BREAK ULUZ)))
	(COND ((PROBEF (SETQ GL (LIST DEV 
				      (MAKNAM (NCONC (EXPLODEN COMPLRVERNO)
						     '(F F)))
				      'FASL))) 
	       (AND (NOT BVARS)
		    (PRINC '|/
Fazloading FASLAP fix file |)
		    (PRINC (CADR GL)))
	       (APPLY 'FASLOAD GL)))
  	(AND (NOT BVARS) (PRINC '|/
Initializing |))
	(INITIALIZE LAP)
	(princ '|/
Loading initial macro definitions,|)
	(FASLOAD MACROD fas dsk (mac lsp))
	(princ'|/
symbol definitions,|)
	(load '((dsk (new lsp)) defsym 1))
	(princ '|/
and patches|)
	((lambda (obarray)
	 (load '((dsk (new lsp)) patch 1)))
	 sobarray)
	(COND ((STATUS FEATURE ITS) 
	       (ALARMCLOCK 'TIME -1)
	       (COND (PURE (PAGEBPORG) (PURIFY 0 0 'BPORG)))))
	(GCTWA)
	(COND (BVARS)
	      (T (PRINC '|/
Total Time = |)
		 (PRINC (*QUO (FIX (*QUO (- (RUNTIME) RUNTIME) 1.0E5)) 10.0))
		 (PRINC '| secs out of |)
		 (PRINC (*QUO (FIX (*$ (-$ (TIME) TIME) 10.0)) 10.0))
		 (TERPRI)))
	(PRINC (COND ((NOT (STATUS FEATURE ITS))
		      '|Ready for SSAVEing with COMPLR |)
		     ((OR (NOT (FIXP PURE)) (STATUS FEATURE XC))
		      '|Dumping eXperimentalCOMPLr on JONL;XC.DMP |)
		     (T '|Dumping COMLAP;CL.DMP |)))
	(PRINC COMPLRVERNO)
	(TERPRI)
	(AND (NULL FXPDL) (SSTATUS NOFEATURE NOLDMSG))
	(SETQ ALARMCLOCK NIL ↑Q NIL ↑W NIL))